home *** CD-ROM | disk | FTP | other *** search
/ BCI NET 2 / BCI NET 2.iso / archives / applications / wp / pmtex.lha / pmtex / src / pmtexa.f < prev    next >
Encoding:
Text File  |  1995-03-03  |  20.4 KB  |  684 lines
  1. cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
  2. cc                                                              cc
  3. cc           pmtexa.for Version 1.0     2-18-95                 cc
  4. cc                                                              cc
  5. cc   A production of Dr. Don's PC and Harpsichord Emporium      cc
  6. cc        Don Simons (dsimons@logicon.com), proprietor          cc
  7. cc   "An imaginary gathering place for technoid pluckheads"     cc
  8. cc                                                              cc
  9. cc   This is no-ware: No cost, no license, no guarantee         cc
  10. cc                                                              cc
  11. cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
  12.       logical loop
  13.       integer nn(5),list(4,200),ipl(5,200),nodur(5,200),
  14.      *        nnl(5),itsofar(5),nib(5,15),nask(0:200),lastbar(0:30),
  15.      *        nbarss(30)
  16.       real*4 elsk(200),celsk(0:200),elperbar(30)
  17.       character*80 line
  18.       character*1 acc(5,200)
  19.       character*24 basename,iname(5)
  20.       logical rest(5,200),firstline
  21.       common /comget/ lastchar
  22.       logical lastchar
  23.       common /all/ iv,list,nnl,nv,ibar,ipl,
  24.      *   nodur,jn,lenbar,iccount,nbars,itsofar,nib,nn,
  25.      *   rest,lenbar0,lenbar1,firstline
  26.       common /all/ acc
  27.       common /linecom/ elskl,elskb,naskb
  28.       lastchar = .false.
  29. c
  30. c  iccount: pointer in string from input file.  Just before calling getchar,
  31. c          it points to the last character retrieved. 
  32. c  nnl    : # of notes in a line (//)
  33. c  itsofar: time in current line from start of line
  34. c
  35. c  The following 6 cc commented lines get the basename as a command line
  36. c  argument.  Since they probably only work in Microsoft FORTRAN, I've 
  37. c  replaced them (in the next 2 lines) with a more generic prompt for 
  38. c  inputting the base name.
  39. c  
  40. cc    if (nargs() .ne. 2) then
  41. cc      print*,
  42. cc   *   'There should only be one command line argument!  Try again.'
  43. cc      stop
  44. cc    end if
  45. cc    call getarg(1,basename,lbase)
  46.       print*,'Please type a basename (<9 characters, no dots): '
  47.       read(*,'(a)')basename  
  48.       if (index(basename,'.') .ne. 0) then
  49.         print*,'Do not include extension in basename. Try again.'
  50.         stop
  51.       end if
  52.       lbase = index(basename,' ')-1
  53.       data sfact,widthpt,iwaskpt,fsyst,fbar,wtimesig,vsizi
  54.      *   /   2. , 524.  ,   3   , 0.25,0.18,  10.   , 680./ 
  55.       open(10,file=basename(1:lbase)//'.inp')
  56.       read(10,*)nv,noinst,mtrnum,mtrden,imeter,xmtrnum0,isig,
  57.      *          lpp,nstaves,musicsize,fracindent
  58.       do 6 iv = 1 , nv
  59.         read(10,'(a)')iname(iv)
  60. 6     continue
  61.       read(10,'(a80)')line
  62.       read(10,'(a80)')line
  63.       lpath = index(line,' ')-1
  64.       if (line(lpath:lpath).ne.'/'.and.
  65.      *    line(lpath:lpath).ne.char(92)) then
  66.         print*,
  67.      *   'Last character of pathname is neither / nor '//char(92)//' .'
  68.         print*,'Do you want to continue? ("y" to continue)'
  69.         read(*,'(a)')line
  70.         if (line(1:1).ne.'y' .and. line(1:1).ne.'Y') stop
  71.       end if
  72.       open(12,file='pmtex.dat')
  73.       write(12,'(a)')basename(1:lbase)
  74.       write(12,*)lbase
  75.       ifig = 0
  76.       lenbeat = ifnodur(mtrden,'x')
  77.       lenbar1 = mtrnum*lenbeat
  78.       lenbar0 = xmtrnum0*lenbeat+.1
  79.       if (lenbar0 .ne. 0) then
  80.         ibaroff = 1
  81.         lenbar = lenbar0
  82.       else
  83.         ibaroff = 0
  84.         lenbar = lenbar1
  85.       end if
  86. c
  87. c Vertical analysis.  ixxxfacteur is space in \Interligne's. Page ht (pt) is
  88. c    (musicsize)/4*lpp*(itop+ibot+4+interf*(nv-1)).
  89. c    Assume itop=ibot and itop+ibot=sfact*(interf-4), where sfact is input. 
  90. c
  91.       itopfacteur=(vsizi/lpp/(musicsize/4.)-4*nv)/2/(1+(nv-1)/sfact)+.5
  92.       ibotfacteur = itopfacteur
  93.       interfacteur = (ibotfacteur+itopfacteur)/sfact+4.5
  94.       write(12,*)itopfacteur,ibotfacteur,interfacteur 
  95.       ibarcnt = 0
  96.       iccount = 80
  97. c
  98. c  Initialize for loop over lines
  99. c
  100.       firstline = .true.
  101. 30    loop = .true.
  102.       nbars = 0
  103. 3     do 4 iv = 1 , nv
  104.         itsofar(iv) = 0
  105.         nnl(iv) = 0
  106.         do 5 j = 1 , 200
  107.           rest(iv,j) = .false.
  108.           acc(iv,j) = 'x'
  109. 5       continue
  110. 4     continue 
  111.       iv = 1
  112. 2     if (loop) then
  113. c
  114. c  Within this loop, nv voices are filled up for the duration of the line.
  115. c  On exit (loop=.false.) the following are set: nnl(nv),itsofar(nv)
  116. c  nolev(nv,nnl(nv)),nodur(..),acc(..),rest(..).  nnl will later be
  117. c  increased and things slid around as accidental skips are added.  
  118. c
  119.         call getnote(loop,ifig) 
  120.         if (lastchar) go to 20
  121.         go to 2
  122.       end if
  123.       firstline = .false.
  124.       elskl = 0.
  125.       do 10 ibar = 1 , nbars
  126.         ibarcnt = ibarcnt+1
  127.         print*,'Now processing bar #',ibarcnt-ibaroff
  128.         lenbar = lenbar1
  129.         if (lenbar0.ne.0 .and. ibarcnt.eq.1) lenbar = lenbar0
  130.         if (ibar .gt. 1) then
  131. c
  132. c  For bars after first, slide all stuff down to beginning of arrays
  133. c
  134.           do 11 iv = 1 , nv
  135.             ioff = nib(iv,ibar-1)
  136.             do 12 ip = 1 , nib(iv,ibar)-ioff
  137.               nodur(iv,ip) = nodur(iv,ip+ioff)
  138.               acc(iv,ip) = acc(iv,ip+ioff)
  139.               rest(iv,ip) = rest(iv,ip+ioff)
  140. 12          continue
  141. 11        continue
  142.         end if
  143.         call makeabar()
  144.         elsk(ibarcnt) = elskb
  145.         nask(ibarcnt) = naskb 
  146. 10    continue
  147.       go to 30
  148. 20    continue
  149.       celsk(1) = elsk(1)
  150.       do 21 ibar = 2 , ibarcnt
  151.         celsk(ibar) = celsk(ibar-1)+elsk(ibar)
  152. 21    continue
  153.       nask(0) = 0
  154.       lastbar(0) = 0
  155.       do 22 istaff = 1 , nstaves
  156.         ibarb4 = lastbar(istaff-1)
  157.         if (istaff .eq. 1) then
  158.           elsstarg = celsk(ibarcnt)/(nstaves-fracindent)
  159.           celskb4 = 0.
  160.         else
  161.           celskb4 = celsk(ibarb4)
  162.           elsstarg = (celsk(ibarcnt)-celskb4)/(nstaves-istaff+1)
  163.         end if
  164.         diff1 = abs(elsstarg-elsk(ibarb4+1))
  165.         do 23 ibar = ibarb4+2 , ibarcnt
  166.           diff = elsstarg-(celsk(ibar)-celskb4)
  167.           if (abs(diff) .ge. diff1) go to 24
  168.           diff1 = abs(diff)
  169. 23      continue 
  170. 24      ibar = ibar-1
  171.         lastbar(istaff) = ibar
  172.         nbarss(istaff) = ibar-ibarb4
  173.         elss = celsk(ibar)-celskb4
  174.         elperbar(istaff) = elss/(ibar-ibarb4)
  175.         if (istaff.eq.1.) elperbar(1) = elperbar(1)/(1-fracindent)
  176.         write(12,'(i5)')lastbar(istaff-1)+1
  177. c
  178. c   Count up accidental skips
  179. c
  180.         numask = 0
  181.         do 25 ibr = ibarb4+1, lastbar(istaff)
  182.           numask = numask+nask(ibr)
  183. 25      continue
  184.         ielperbar = elperbar(istaff)
  185. c
  186. c   Check width this would give
  187. c
  188. 26      welsk = ((widthpt-fsyst*musicsize)/nbarss(istaff)
  189.      *      -fbar*musicsize)/ielperbar
  190.         wten = welsk*elss 
  191.         finow = 0.
  192.         if (istaff.eq.1) finow = fracindent
  193.         wavail = widthpt*(1-finow)-numask*iwaskpt
  194.         if (istaff .eq. 1) wavail = wavail-wtimesig
  195.         if (wavail .lt. wten) then
  196.           ielperbar = ielperbar+1
  197.           go to 26
  198.         end if
  199.         write(12,'(a7,i2,a2,i2,a2,i2,a1)')
  200.      *     char(92)//'autol{',ielperbar,'}{',nbarss(istaff),
  201.      *       '}{',lpp,'}%'
  202. 22    continue
  203.       write(12,'(i5)')0
  204.       open(13,file='pmtex.fig')
  205.       write(13,'(i5)')ifig
  206.       close(12)
  207.       close(13)
  208.       print*,'Done with first pass.  Now run pmTeXb.'
  209.       end
  210.       subroutine getnote(loop,ifig)
  211.       common /all/ iv,list(4,200),nnl(5),nv,ibar,
  212.      *   ipl(5,200),
  213.      *   nodur(5,200),jn,lenbar,iccount,nbars,itsofar(5),
  214.      *   nib(5,15),nn(5),
  215.      *   rest(5,200),lenbar0,lenbar1,firstline
  216.       common /all/ acc(5,200)
  217.       common /comget/ lastchar
  218.       logical lastchar,firstline
  219.       character*1 acc
  220.       logical rest
  221.       character*80 line
  222.       logical loop
  223.       character*1 char,oct,dot,dum
  224. 1     call getchar(line,iccount,char)
  225.       if (lastchar) return
  226.       if (char .eq. ' ') then
  227.         go to 1
  228.       else if (char .eq. '%') then
  229.         iccount = 80
  230.         go to 1
  231.       else if (ichar(char).ge.97 .and. ichar(char).le.103) then
  232. c
  233. c This is a note.  Increase note count, get octave & basic duration.
  234. c
  235.         nnl(iv) = nnl(iv)+1
  236.         call getchar(line,iccount,oct)
  237.       if (lastchar) return
  238.         dot = 'x'
  239.         if (oct .ne. ' ') then
  240.           read(oct,'(i1)')ioct
  241.           call getchar(line,iccount,char)
  242.       if (lastchar) return
  243.         else
  244. c#### Get octave from previous one
  245.           char = ' '
  246.         end if 
  247.         if (char .eq. ' ') then
  248.           nodur(iv,nnl(iv)) = nodur(iv,nnl(iv)-1)
  249.           go to 4
  250.         end if
  251.         read(char,'(i1)')inodur
  252. 2       call getchar(line,iccount,char)
  253.       if (lastchar) return
  254.         if (char .ne. ' ') then
  255.           if (char .eq. 'd') then
  256.             dot = char
  257.           else if (char .eq. '/') then
  258.             continue
  259.           else
  260. c
  261. c  Only other possibility is an accidental
  262. c
  263.             acc(iv,nnl(iv)) = char
  264.           end if
  265.           if (char .ne. '/') go to 2
  266.         end if
  267.         nodur(iv,nnl(iv)) = ifnodur(inodur,dot)
  268. 4       itsofar(iv) = itsofar(iv)+nodur(iv,nnl(iv))
  269.         if (mod(itsofar(iv),lenbar) .eq. 0) then
  270.           nbars = nbars+1
  271.           nib(iv,nbars) = nnl(iv)
  272.           if (lenbar .ne. lenbar1) then
  273. c
  274. c###  Just finished the pickup bar for this voice.
  275. c
  276.             lenbar = lenbar1
  277.             itsofar(iv) = 0
  278.           end if
  279.         end if 
  280.       else if (char .eq. 'o') then
  281. c###             "o" symbol must come AFTER the affected note
  282.         call getchar(line,iccount,dum) 
  283.         if (lastchar) return
  284.       else if ((ichar(char).ge.49.and.ichar(char).le.57) .or.
  285.      *    char.eq.'#' .or. char.eq.'-' .or. char.eq.'n'
  286.      *    .or. char.eq.'_') then
  287. c###            We have a figure.  Must come AFTER the note it goes under
  288. 5       call getchar(line,iccount,char)
  289.         ifig = 1
  290.         if (lastchar) return
  291.         if (char .ne. ' ') then
  292.           go to 5
  293.         end if
  294.       else if (char .eq. 'r') then
  295. c
  296. c  We have a rest, so get inodur and dot
  297. c
  298.         nnl(iv) = nnl(iv) + 1
  299.         rest(iv,nnl(iv)) = .true.
  300.         call getchar(line,iccount,char)
  301.       if (lastchar) return
  302.         read(char,'(i1)')inodur
  303.         dot = 'x'
  304.         call getchar(line,iccount,char)
  305.       if (lastchar) return
  306.         if (char .eq. 'd') then
  307.           dot = char
  308.         end if 
  309.         nodur(iv,nnl(iv)) = ifnodur(inodur,dot)
  310.         itsofar(iv) = itsofar(iv)+nodur(iv,nnl(iv))
  311.         if (mod(itsofar(iv),lenbar) .eq. 0) then
  312.           nbars = nbars+1
  313.           nib(iv,nbars) = nnl(iv)
  314.           if (lenbar .ne. lenbar1) then
  315. c
  316. c###  Just finished the pickup bar for this voice
  317. c
  318.             lenbar = lenbar1
  319.             itsofar(iv) = 0
  320.           end if
  321.         end if 
  322.       end if
  323. 3     if (char .eq. '/') then
  324. c
  325. c  Start a new voice for this line
  326. c
  327.         if (iv .eq. 1) then
  328.           if (mod(itsofar(iv),lenbar) .ne. 0) then
  329.             print*,'Beats in 1st voice not divisible by barlength'
  330.             stop
  331.           end if
  332.         else if (itsofar(iv) .ne. itsofar(1)) then
  333.           print*,'Error in timing, voice',iv
  334.           stop
  335.         end if
  336.         if (iv .eq. nv) then
  337.           loop = .false.
  338.         else
  339.           nbars = 0
  340.           iv = iv+1
  341.           if (lenbar0.ne.0 .and. firstline) lenbar = lenbar0
  342.         end if
  343.       end if
  344.       return
  345.       end
  346.       subroutine getchar(line,iccount,char)
  347.       common /comget/ lastchar
  348.       logical lastchar
  349. c
  350. c  Gets the next character out of line*80.  If pointer iccount=80 on entry,
  351. c  then reads in a new line.  Resets iccount.  Ends program if no more input.  
  352. c
  353.       character*1 char 
  354.       character*80 line
  355.       if (iccount .eq. 80) then
  356.         read(10,'(a80)',end=999)line
  357.         iccount = 0
  358.       end if
  359.       iccount = iccount+1
  360.       char = line(iccount:iccount)
  361.       return
  362. 999   continue
  363.       lastchar = .true.
  364.       return
  365.       end
  366.       function log2(n)
  367.         log2 = alog(n*1.)/0.69315+.01
  368.       return
  369.       end
  370.       function ifnodur(idur,dot)
  371.         character*1 dot
  372.         if(idur .eq. 3)then
  373.           ifnodur=3
  374.         else if(idur .eq. 1) then
  375.           ifnodur=6 
  376.         else if(idur .eq. 8) then
  377.           ifnodur=12 
  378.         else if(idur .eq. 4) then
  379.           ifnodur=24 
  380.         else if(idur .eq. 2) then
  381.           ifnodur=48
  382.         else if(idur .eq. 0) then
  383.           ifnodur=96
  384.         else 
  385.           print*,'You entered an invalid note-length value'
  386.           stop
  387.         end if
  388.         if (dot .eq. 'd') ifnodur = ifnodur*1.5+.5
  389.       return
  390.       end
  391.       subroutine makeabar()
  392.       common /all/ iv,list(4,200),nnl(5),nv,ibar,
  393.      *   ipl(5,200),
  394.      *   nodur(5,200),jn,lenbar,iccount,nbars,itsofar(5),
  395.      *   nib(5,15),nn(5),
  396.      *   rest(5,200),lenbar0,lenbar1,firstline
  397.       common /all/ acc(5,200)
  398.       common /linecom/ elskl,elskb,naskb
  399.       character*1 acc
  400.       logical rest,firstline
  401.       integer it(5),cnn(5),istart(20),istop(20),itstart(20),
  402.      *   nspace(20),nindex(20)
  403.       elskb = 0.
  404.       naskb = 0
  405.       do 1 iv = 1 , nv
  406.         if (ibar .gt. 1) then
  407.           nn(iv) = nib(iv,ibar)-nib(iv,ibar-1)
  408.         else
  409.           nn(iv) = nib(iv,ibar)
  410.         end if
  411. 1     continue
  412. c
  413. c initialize list note counter, time(iv), curr. note(iv)
  414. c
  415.       ilnc = 1
  416.       do 4 iv = 1 , nv
  417.         if (nn(iv) .gt. 1) then
  418.           it(iv) = nodur(iv,1)
  419.         else
  420.           it(iv) = 1000
  421.         end if
  422.         cnn(iv) = 1
  423.         list(1,ilnc) = iv
  424.         list(2,ilnc) = 1
  425.         ilnc = ilnc+1
  426. 4     continue
  427. c
  428. c  Build the list
  429. c
  430. 5     continue
  431. c
  432. c  Determine which voice comes next from end of notes done so far.
  433. c  itmin is the earliest ending time of notes done so far
  434. c
  435.       itmin = 1000
  436.       do 6 iv = 1 , nv
  437.         itminn = min(itmin,it(iv))
  438.         if(itminn .lt. itmin) then
  439.           itmin = itminn
  440.           ivnext = iv
  441.         end if
  442. 6     continue
  443.       if (itmin .eq. 1000) go to 7
  444.       list(1,ilnc) = ivnext
  445.       cnn(ivnext) = cnn(ivnext)+1
  446.       list(2,ilnc) = cnn(ivnext) 
  447.       list(3,ilnc) = itmin
  448. c
  449. c  Check if this voice is done
  450. c           
  451.       if (cnn(ivnext) .eq. nn(ivnext)) then
  452.         it(ivnext) = 1000
  453.       else
  454.         it(ivnext) = it(ivnext)+nodur(ivnext,cnn(ivnext)) 
  455.       end if
  456.       ilnc = ilnc+1
  457.       go to 5
  458. 7     continue
  459.       ntot = ilnc-1
  460.       do 8 in = 1 , ntot-1
  461.         list(4,in) = list(3,in+1)-list(3,in)
  462. 8     continue
  463.       list(4,ntot) = nodur(list(1,ntot),list(2,ntot))
  464. c
  465. c  Done w/ list, but for special checks. First, for full-bar rests
  466. c
  467.       do 30 iv = 1 , nv
  468.         if (nodur(iv,1).eq.lenbar.and.rest(iv,1).and.ntot.gt.nv) then
  469. c
  470. c  Find the last list position (in) before the half-bar
  471. c
  472.           do 31 in = 1 , ntot-1
  473.             if (list(3,in+1) .ge. lenbar/2) go to 32
  474. 31        continue
  475.           print*,'Mess-up looking for half-bar'
  476.           stop
  477. 32        itwrest = list(3,in)
  478. c
  479. c  Backup to spot for inserting rest marker, i.e., one to the right of 
  480. c  the first place where either list(1)<iv or list(3)<itwrest 
  481. c
  482.           do 33 iin = in-1 , 1 , -1
  483.             if(list(1,iin).lt.iv.or.list(3,iin).lt.itwrest)go to 34
  484. 33        continue
  485.           print*,'Problem backing up from half bar'
  486. c         stop
  487. 34        infr = iin+1
  488.           call add2list(infr,2,itwrest,lenbar-itwrest,'w',.true.,
  489.      *     ntot,istart,istop,nb)
  490.           nodur(iv,1) = itwrest
  491.           acc(iv,1) = 'b'
  492.         end if
  493. 30    continue  
  494. c
  495. c  A kluged up loop for building note blocks:
  496. c
  497.       ib = 1 
  498.       istart(1) = 1
  499.       nspace(1) = 0
  500.       in = 1 
  501. 9     continue
  502.         if (in .eq. ntot) then
  503.           if (nspace(ib) .eq. 0) nspace(ib)=list(4,in)
  504.           istop(ib) = ntot
  505. c Now we flow out of this if and into block-building      
  506.         else if (nspace(ib) .eq. 0) then
  507. c nspace hasn't been set yet, so 
  508. c and tentatively set:
  509.           nspace(ib) = list(4,in)
  510.           if (nspace(ib) .eq. 0) then
  511.             in=in+1
  512.           else
  513.             istop(ib) = in
  514.           end if
  515.           go to 9
  516.         else if (list(4,in+1) .eq. 0) then
  517. c This is not the last note in the group, so
  518.           in = in+1
  519.           go to 9 
  520.         else if (list(4,in+1) .eq. nspace(ib)) then
  521. c Keep spacing the same, update tentative stop point
  522.           in = in+1
  523.           istop(ib) = in
  524.           go to 9
  525.         end if
  526. c
  527. c At this point istart and istop are good, so on to next block 
  528. c
  529.         itstart(ib) = list(3,istart(ib))
  530.         nindex(ib) = log2(nspace(ib)/2)+1
  531.         elsperns = 2.**((nindex(ib)-1)/2.)
  532.         if (istop(ib) .eq. ntot) then
  533.           nnsk = (lenbar-itstart(ib))/nspace(ib)
  534.           elskl = elskl+elsperns*nnsk
  535.           elskb = elskb+elsperns*nnsk
  536.           go to 15
  537.         end if
  538.         nnsk = (list(3,istop(ib)+1)-itstart(ib))/nspace(ib)
  539.         elskl = elskl+elsperns*nnsk
  540.         elskb = elskb+elsperns*nnsk
  541.         ib = ib+1
  542.         istart(ib) = istop(ib-1)+1
  543.         in = istart(ib)
  544. c
  545. c Set tentative block space for new block
  546. c
  547.         nspace(ib) = list(4,in)
  548.         istop(ib) = in
  549.       go to 9          
  550. 15    continue
  551.       nb = ib
  552. c
  553. c  Now add to list special codes for accidental skips.  This is a loop on
  554. c  in up to ntot, but ntot increases when a skip is added, so loop manually
  555. c  Must bypass this loop if all there are are whole rests.
  556.       if (ntot .eq. nv) go to 40
  557.       in = 2
  558. 39    continue
  559.         jv = list(1,in)
  560.         ip = list(2,in)
  561.         itim = list(3,in)
  562.         if ((acc(jv,ip).eq.'f' .or. acc(jv,ip).eq.'n'
  563.      *      .or. acc(jv,ip).eq.'s') .and. nodur(jv,ip-1).le.6 .and.
  564.      *       ip.ge.2 .and. acc(jv,ip-1).ne.'a') then
  565. c         print*,'I got into ask zone!!!'
  566.           naskb = naskb+1
  567. c
  568. c  Need accidental skip. Find block # for list position "in".
  569. c
  570.           do 45 ib = 1 , nb
  571.             if (istop(ib) .ge. in) go to 46
  572. 45        continue
  573.           print*,'Got lost looking for ib!!'
  574. 46        continue
  575.           do 42 iv = nv , 1 , -1
  576.             if (iv .eq. jv) then
  577.               iip = ip
  578.               iin = in
  579.               iitim = itim
  580.             else if (nn(iv) .eq. 1) then
  581.               go to 42
  582.             else
  583. c 
  584. c  Find ip# for this voice at this itim !!!  
  585. c
  586.               do 43 iin = 2 , ntot
  587.                 if (list(1,iin).eq.iv.and.list(3,iin).ge.itim)then
  588. c
  589. c  Check if in the same block as the offending accidental
  590. c
  591.                   if (istop(ib) .ge. iin) go to 44
  592. c
  593. c  Note is in next block, so no skip needed.
  594. c
  595.                   go to 42
  596.                 end if
  597. 43            continue
  598. c
  599. c No skip needed, since no new notes after the one in question, so
  600. c
  601.               go to 42
  602. 44            iip = list(2,iin)
  603.               iitim = list(3,iin)
  604.             end if
  605.             call add2list(iin,iip,iitim,0,'a',.true.,ntot,
  606.      *         istart,istop,nb)
  607. 42        continue
  608.         end if
  609.       if (in .eq. ntot) go to 40 
  610.       in = in+1
  611.       go to 39
  612. 40    continue              
  613. c
  614. c  Invert the list of places, to make it easier to analyze a voice
  615. c
  616.       do 13 in = 1 , ntot
  617.         ipl(list(1,in),list(2,in)) = in
  618. 13    continue 
  619.       return
  620.       end
  621.       subroutine add2list(infr,newip,newstrt,newdur,newacc,newrest,
  622.      *     ntot,istart,istop,nb)
  623. c
  624. c  This inserts into the list a new "note" at location infr.  Inputs vars are
  625. c     (iv) = voice # (in common)
  626. c     newip = position in voice, from beginning of bar
  627. c     newstrt = starting time of new "note"
  628. c     newdur =  duration
  629. c     newacc = accidental value
  630. c     newrest = rest value
  631. c     
  632.       common /all/ iv,list(4,200),nnl(5),nv,ibar,
  633.      *   ipl(5,200),
  634.      *   nodur(5,200),jn,lenbar,iccount,nbars,itsofar(5),
  635.      *   nib(5,15),nn(5),
  636.      *   rest(5,200),lenbar0,lenbar1,firstline
  637.       common /all/ acc(5,200)
  638.       character*1 acc
  639.       logical rest,firstline
  640.         character*1 newacc
  641.         logical newrest
  642.         integer istart(20),istop(20)
  643. c
  644. c  Move everything in the list to the right by one spot, and adjust ip
  645. c    for notes in affected voice.
  646. c
  647.         do 34 in = ntot , infr , -1
  648.           if (list(1,in).eq.iv) list(2,in) = list(2,in)+1
  649.           do 35 il = 1 , 4
  650.             list(il,in+1) = list(il,in)
  651. 35        continue
  652. 34      continue
  653. c
  654. c  Move everything in nodur,rest,acc,nolev to the right by one 
  655. c
  656.         do 36 ip = nnl(iv) , newip , -1
  657.           nodur(iv,ip+1) = nodur(iv,ip)
  658.           acc(iv,ip+1) = acc(iv,ip)
  659.           rest(iv,ip+1) = rest(iv,ip)
  660. 36      continue
  661.         nnl(iv) = nnl(iv)+1
  662.         do 37 iibar = ibar , nbars 
  663.           nib(iv,iibar) = nib(iv,iibar)+1
  664. 37      continue
  665.         ntot = ntot+1
  666.         nn(iv) = nn(iv)+1
  667.         nodur(iv,newip) = newdur
  668.         rest(iv,newip) = newrest
  669.         acc(iv,newip) = newacc
  670.         list(1,infr) = iv
  671.         list(2,infr) = newip
  672.         list(3,infr) = newstrt
  673.         list(4,infr) = list(3,infr+1)-list(3,infr)
  674.         list(4,infr-1) = list(3,infr)-list(3,infr-1)
  675. c
  676. c Check the note blocks
  677. c
  678.         do 38 ib = 1 , nb
  679.           if (infr .le. istop(ib)) istop(ib) = istop(ib)+1
  680.           if (infr .lt. istart(ib)) istart(ib) = istart(ib)+1
  681. 38      continue            
  682.       return
  683.       end
  684.